home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / modula2 / hk_lib / def_mod / stacks.mod < prev    next >
Encoding:
Modula Implementation  |  1994-09-22  |  21.8 KB  |  636 lines
  1. IMPLEMENTATION MODULE  Stacks;
  2.  
  3. (*****************************************************************************)
  4. (* Jeder Stack hat auch im Header seine eigene Adresse gespeichert, damit    *)
  5. (* sichergestellt werden kann, dass mit einem definierten Stack gearbeitet   *)
  6. (* wird. Um allerdings jedesmal die Adresse ueberpruefen zu koennen, muss der*)
  7. (* Stack immer als VAR-Parameter uebergeben werden, sonst kommt man nicht    *)
  8. (* mehr an die Adresse ran.                                                  *)
  9. (* Wer will, kann ja die Adressenabfrage aus den Prozeduren entfernen.       *)
  10. (*                                                                           *)
  11. (* Zur Speicherverwaltung siehe Kopftext des "Queues"-Implementationsmoduls. *)
  12. (* Im Gegensatz zu einer Queue braucht beim Stack nur die Adresse des ober-  *)
  13. (* sten Blocks bekannt zu sein, da auch nur von dieser Seite auf den Stack   *)
  14. (* zugegriffen wird.                                                         *)
  15. (*                                                                           *)
  16. (*                                                                           *)
  17. (*       stack                oberster Block         unterster Block         *)
  18. (*                                                   voll                    *)
  19. (*          | <----                                                          *)
  20. (*          |      |         ________________        ________________        *)
  21. (*  ________V______|_       |                |      :                :       *)
  22. (* | stackAdr        |      |   noch frei    |      :                :       *)
  23. (* |-----------------|      |................|      :   belegt       :       *)
  24. (* :                 :   -->| oberstes Elem  |      :                :       *)
  25. (* |-----------------|  |   |----------------|      :----------------:       *)
  26. (* | stackTop        |--    :   belegt       :      : unterstes Elem :       *)
  27. (* |-----------------|      |----------------|      |----------------|       *)
  28. (* | topBlock        |----->| naechsterBlock |-~~~~>|     NIL        |       *)
  29. (* |_________________|      |________________|      |________________|       *)
  30. (*                                                                           *)
  31. (*                                                                           *)
  32. (*___________________________________________________________________________*)
  33. (*                                                                           *)
  34. (*   03-Mai-89, hk                                                           *)
  35. (*         Beginn, erste Version                                             *)
  36. (*   29-Jul-89, hk                                                           *)
  37. (*         SpezialRecord 'Adresse' entfallen, Rueckgabewerte von Proz.,      *)
  38. (*         nicht gleich Abbruch                                              *)
  39. (*   20-Aug-89, hk                                                           *)
  40. (*         Rueckgabewerte nur noch BOOLEAN                                   *)
  41. (*   04-Sep-89, hk                                                           *)
  42. (*         Bei gelinktem Modul Abbruch mit Pterm0                            *)
  43. (*   29-Dez-89, hk                                                           *)
  44. (*         Ein paar kleinere ( rauesper ) Fehler beseitigt.                  *)
  45. (*         Die Speicherplatzgroesse wird jetzt beim Einrichten des Stacks    *)
  46. (*         festgelegt, eine Fehlermeldung wegen falscher Groesse gibt es     *)
  47. (*         jetzt auch bei "TopOfStack" und "Pop".                            *)
  48. (*         Der Stack enthaelt zur Konsistenzpruefung seine eigene Adresse    *)
  49. (*         und auch die Anzahl der auf dem Stack liegenden Elemente, die mit *)
  50. (*         der neuen Funktion "Length" festgestellt werden kann. Es folgt    *)
  51. (*         Fehlermeldung und Programmabbruch, falls mit einem undefinierten  *)
  52. (*         Stack gearbeitet wird. Separater Errorhandler.                    *)
  53. (*         Fuer das Kopieren der Stackelemente werden Prozeduren aus dem     *)
  54. (*         Modul "Memory" benutzt.                                           *)
  55. (*         Kuerzung der Namen ( Anhaengsel 'Stack' entfernt ), um eine       *)
  56. (*         Qualifizierung schmackhafter zu machen - ist uebersichtlicher.    *)
  57. (*   30-Dez-89, hk                                                           *)
  58. (*         Je nach Groesse der auf dem Stack abzulegenden Daten wird die     *)
  59. (*         entsprechende Kopierprozedur aus "Memory" schon beim Anlegen des  *)
  60. (*         Stacks ausgewaehlt.                                               *)
  61. (*   23-Feb-90, hk                                                           *)
  62. (*         voellig neue Block-Speicherverwaltung, automatischer Errorhandler *)
  63. (*         <done> als Prozedurrueckgabe, extra Fehlerrueckgabe mit           *)
  64. (*         "LastStackResult"                                                 *)
  65. (*****************************************************************************)
  66.  
  67.  
  68. FROM   SYSTEM   IMPORT  (* TYPE *)  BYTE, ADDRESS,
  69.                         (* PROC *)  VAL, INLINE, ADR, LONG;
  70.  
  71. FROM   HEAP     IMPORT  (* PROC *)  Allocate, Deallocate;   (* = Storage ?? *)
  72.  
  73. IMPORT MEMORY;    (*    (* TYPE *)  CopyProc,
  74.                         (* PROC *)  ClearMem, CopySmallMem, CopyMem;
  75.                    *)
  76.  
  77. (* ===========================  T Y P E N  ================================= *)
  78.  
  79. TYPE
  80.       block     = POINTER TO block;  (* ...schaut rekursiv aus, ist aber ok *)
  81.  
  82.  
  83.       Stack     = POINTER TO StackInfo;
  84.  
  85.       StackInfo = RECORD
  86.          stackAdr    : ADDRESS;          (* Adresse eines Stacks           *)
  87.          Copy        : MEMORY.CopyProc;  (* Prozedur fuers Wertekopieren   *)
  88.          elemSize    : CARDINAL;         (* Groesse eines Stackelements    *)
  89.          maxElement  : LONGINT;          (* Max. Elementindex im Block     *)
  90.          blockSize   : LONGINT;          (* Groesse eines Speicherblocks   *)
  91.          Elemente    : CARDINAL;         (* Anzahl der Stackelemente       *)
  92.          topElement  : LONGINT;          (* Index des obersten Elementes   *)
  93.                                          (* innerhalb des obersten Blocks  *)
  94.          stackTop    : ADDRESS;          (* Adresse des obersten Elementes *)
  95.          topBlock    : block;            (* Adresse des obersten Blocks    *)
  96.       END;
  97.  
  98.  
  99. (* ========================================================================= *)
  100. (* =====================   L O K A L   ===================================== *)
  101.  
  102. VAR
  103.      lastResult   : StackResult;
  104.  
  105.      Stackhandler : StackHandler;
  106.      handlerOn    : BOOLEAN;
  107.  
  108. (* ------------------------------------------------------------------------- *)
  109.  
  110. PROCEDURE  emptyStackHandler ((* EIN/ -- *) proc  : ARRAY OF CHAR;
  111.                               (* EIN/ -- *) stErr : StackResult   );
  112. (*T*)
  113. (* nur damit das System nicht abstuerzt, falls aus irgendeinem
  114.    Grund der Handler aktiviert wird, obwohl keiner definiert wurde...
  115. *)
  116.  BEGIN
  117.  END  emptyStackHandler;
  118.  
  119. (* ------------------------------------------------------------------------- *)
  120.  
  121. PROCEDURE  ReleaseBlock ((* EIN/AUS *) VAR stack : Stack );
  122. (*T*)
  123. (* Lokale Hilfsprozedur fuer "Delete", "Clear", "Drop" und "Pop".
  124.    Entfernt ohne Sicherheitsabfrage den obersten Block vom Stack.
  125.    Der Speicherplatz des Blocks wird freigegeben.
  126. *)
  127.    VAR  alterBlock : block;
  128.  
  129.    BEGIN
  130.      WITH  stack^  DO
  131.        alterBlock := topBlock;   (* Element muss referenzierbar *)
  132.                                  (* bleiben                     *)
  133.        topBlock   := topBlock^;  (* Element aus der Zeigerkette *)
  134.                                  (* nehmen                      *)
  135.        Deallocate( alterBlock, blockSize );
  136.      END; (* WITH *)
  137.    END  ReleaseBlock;
  138.  
  139.  
  140. (* Ende LOKAL ============================================================== *)
  141.  
  142. PROCEDURE  LastStackResult ( ): StackResult;
  143. (*T*)
  144.  BEGIN
  145.    RETURN( lastResult );
  146.  END  LastStackResult;
  147.  
  148. (* ------------------------------------------------------------------------- *)
  149.  
  150. PROCEDURE  AssignStackHandler ((* EIN/ -- *) handler : StackHandler );
  151. (*T*)
  152.  BEGIN
  153.    Stackhandler := handler;
  154.    handlerOn    := TRUE;
  155.    lastResult   := stackOk;
  156.  END  AssignStackHandler;
  157.  
  158. (* ------------------------------------------------------------------------- *)
  159.  
  160. PROCEDURE  UnAssignStackHandler;
  161. (*T*)
  162.  BEGIN
  163.    handlerOn    := FALSE;
  164.    Stackhandler := emptyStackHandler;
  165.    lastResult   := stackOk;
  166.  END  UnAssignStackHandler;
  167.  
  168. (* ------------------------------------------------------------------------- *)
  169.  
  170. PROCEDURE  Create ((* EIN/ -- *)     groesse : CARDINAL;
  171.                    (* EIN/ -- *)     blkElem : CARDINAL;
  172.                    (* -- /AUS *) VAR stack   : Stack;
  173.                    (* -- /AUS *) VAR done    : BOOLEAN  );
  174. (*T*)
  175.   CONST  procName = 'Create';
  176.  
  177.   BEGIN
  178.     IF  groesse = 0  THEN  groesse := 1;  END;
  179.     IF  blkElem = 0  THEN  blkElem := 1;  END;
  180.  
  181.     done := FALSE;
  182.  
  183.     Allocate( stack, SIZE( stack^ ));   (* = NEW( stack )  *)
  184.     IF  stack # NIL  THEN
  185.  
  186.        WITH  stack^  DO
  187.          blockSize := LONG( blkElem ) * LONG( groesse ) + LONG( SIZE( block ));
  188.  
  189.          Allocate( topBlock, blockSize );
  190.          IF  topBlock # NIL  THEN
  191.  
  192.             (* Sowohl fuer den Stack-Header, als auch fuer
  193.              * den ersten Block gabs genuegend Speicher.
  194.              *)
  195.  
  196.             topBlock^  := NIL;   (* letzter Block *)
  197.  
  198.             done       := TRUE;
  199.             lastResult := stackOk;
  200.  
  201.             IF  groesse <= 10  THEN
  202.               (* Bei weniger als 10 Bytes ist diese
  203.                * Prozedur schneller, und ueberlappende
  204.                * Speicherbereiche duerfte es hier eigent-
  205.                * lich nicht geben.
  206.                *)
  207.               Copy := MEMORY.CopySmallMem;
  208.             ELSE
  209.               Copy := MEMORY.CopyMem;
  210.             END; (* IF groesse *)
  211.  
  212.             stackAdr   := ADR( stack ); (* Stack definiert *)
  213.             elemSize   := groesse;
  214.             maxElement := VAL( LONGINT, blkElem - 1 );
  215.             Elemente   := 0;
  216.             topElement := -1;
  217.             stackTop   := VAL( LONGINT, topBlock ) + LONG( SIZE( block ))
  218.                                                    - LONG( elemSize );
  219.          END; (* IF topBlock *)
  220.        END; (* WITH stack^ *)
  221.     END; (* IF stack *)
  222.  
  223.     IF  ~done  THEN
  224.        lastResult := noMem;
  225.        stack      := NIL;
  226.  
  227.        IF  handlerOn  THEN
  228.          Stackhandler( procName, noMem );
  229.        END;
  230.     END; (* IF ~done *)
  231.   END  Create;
  232.  
  233. (* ------------------------------------------------------------------------- *)
  234.  
  235. PROCEDURE  Clear ((* EIN/AUS *) VAR stack : Stack;
  236.                   (* -- /AUS *) VAR done  : BOOLEAN );
  237. (*T*)
  238.   CONST  procName = 'Clear';
  239.  
  240.   BEGIN
  241.     IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  242.  
  243.        WITH  stack^  DO
  244.          WHILE  topBlock^ # NIL  DO
  245.  
  246.            (* Alle evtl. vorhandenen Bloecke ausser dem
  247.             * ersten entfernen.
  248.             *)
  249.            ReleaseBlock( stack );
  250.          END;(* WHILE topBlock^ *)
  251.  
  252.          Elemente   := 0;
  253.          topElement := -1;
  254.          stackTop   := VAL( LONGINT, topBlock ) + LONG( SIZE( block ))
  255.                                                 - LONG( elemSize );
  256.          done       := TRUE;
  257.          lastResult := stackOk;
  258.        END; (* WITH stack^*)
  259.  
  260.     ELSE  (* <stack> undefiniert *)
  261.  
  262.        done       := FALSE;
  263.        lastResult := defErr;
  264.  
  265.        IF  handlerOn  THEN
  266.          Stackhandler( procName, defErr );
  267.        END;
  268.     END; (* stack # NIL... *)
  269.   END  Clear;
  270.  
  271. (* ------------------------------------------------------------------------- *)
  272.  
  273. PROCEDURE  Delete ((* EIN/AUS *) VAR stack : Stack;
  274.                    (* -- /AUS *) VAR done  : BOOLEAN );
  275. (*T*)
  276.   CONST  procName = 'Delete';
  277.  
  278.   BEGIN
  279.     IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  280.       Clear( stack, done );
  281.  
  282.       (* <done> ist nur dummy-Parameter, da auf undefinierten
  283.        * Stack schon hier geprueft wurde.
  284.        * Jetzt noch obersten Block und den Stackheader entfernen.
  285.        *)
  286.  
  287.       Deallocate( stack^.topBlock, SIZE( stack^.blockSize ));
  288.       Deallocate( stack, SIZE( stack^ ));
  289.  
  290.       stack      := NIL;
  291.  
  292.       done       := TRUE;
  293.       lastResult := stackOk;
  294.  
  295.     ELSE  (* <stack> undefiniert *)
  296.  
  297.       done       := FALSE;
  298.       lastResult := defErr;
  299.  
  300.       IF  handlerOn  THEN
  301.         Stackhandler( procName, defErr );
  302.       END;
  303.     END;
  304.   END  Delete;
  305.  
  306. (* ------------------------------------------------------------------------- *)
  307.  
  308. PROCEDURE  IsEmpty ((* EIN/ -- *) VAR stack : Stack ): BOOLEAN;
  309. (*T*)
  310.   CONST  procName = 'IsEmpty';
  311.  
  312.   BEGIN
  313.     IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  314.  
  315.       lastResult := stackOk;
  316.  
  317.       RETURN( stack^.Elemente = 0 );
  318.  
  319.     ELSE  (* <stack> undefiniert *)
  320.  
  321.       lastResult := defErr;
  322.       IF  handlerOn  THEN
  323.         Stackhandler( procName, defErr );
  324.       END;
  325.  
  326.       RETURN( TRUE );
  327.     END;
  328.   END  IsEmpty;
  329.  
  330. (* ------------------------------------------------------------------------- *)
  331.  
  332. PROCEDURE  Length ((* EIN/ -- *) VAR stack : Stack ): CARDINAL;
  333. (*T*)
  334.   CONST  procName = 'Length';
  335.  
  336.   BEGIN
  337.     IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  338.  
  339.       lastResult := stackOk;
  340.  
  341.       RETURN( stack^.Elemente );
  342.  
  343.     ELSE  (* <stack> undefiniert *)
  344.  
  345.       lastResult := defErr;
  346.       IF  handlerOn  THEN
  347.         Stackhandler( procName, defErr );
  348.       END;
  349.  
  350.       RETURN( 0 );
  351.     END;
  352.   END  Length;
  353.  
  354. (* ------------------------------------------------------------------------- *)
  355.  
  356. PROCEDURE  Push ((* EIN/ -- *)     wert  : ARRAY OF BYTE;
  357.                  (* EIN/AUS *) VAR stack : Stack;
  358.                  (* -- /AUS *) VAR done  : BOOLEAN       );
  359. (*T*)
  360.   CONST  procName = 'Push';
  361.  
  362.   VAR  neuerBlock : block;
  363.  
  364.   BEGIN
  365.     done       := FALSE;   (* wird nur bei Erfog geaendert *)
  366.     lastResult := defErr;  (* wird je nach Fehler gesetzt  *)
  367.  
  368.     WITH  stack^  DO
  369.       IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  370.  
  371.         IF  elemSize # VAL( CARDINAL, HIGH( wert )) + 1   THEN
  372.  
  373.            (* Der Speicherplatz eines Feldes von BYTES laesst
  374.             * sich natuerlich aus der Obergrenze des Feldes
  375.             * berechnen. Hier stimmt der Speicherbedarf nicht
  376.             * mit der Definition ueberein.
  377.             *)
  378.            lastResult := sizeErr;
  379.  
  380.         ELSE (* Speicherplatz stimmt *)
  381.  
  382.           IF  topElement < maxElement  THEN
  383.             (* Fuer das neue Element ist noch Platz im Block *)
  384.  
  385.             INC( topElement );
  386.             INC( stackTop, elemSize );
  387.  
  388.             done := TRUE;
  389.  
  390.           ELSE (* neuer Block faellig *)
  391.  
  392.             (* Der Speicher fuer den neuen Block
  393.              * wird beschafft.
  394.              *)
  395.             Allocate( neuerBlock, blockSize );
  396.  
  397.             IF  neuerBlock = NIL  THEN
  398.               lastResult:= noMem;  (* Kein Speicher mehr *)
  399.  
  400.             ELSE (* alles klar *)
  401.  
  402.               neuerBlock^ := topBlock;   (* neuen Block einklinken *)
  403.               topBlock    := neuerBlock;
  404.  
  405.               topElement  := 0;
  406.               stackTop    := VAL( ADDRESS, topBlock ) + LONG( SIZE( block ));
  407.  
  408.               done        := TRUE;
  409.             END; (* IF neuerBlock *)
  410.           END; (* IF topElement *)
  411.         END; (* IF elemSize *)
  412.       END; (* IF stack # NIL *)
  413.  
  414.       IF  done  THEN
  415.  
  416.         Copy( ADR( wert ), stackTop, elemSize );
  417.         INC( Elemente );
  418.         lastResult  := stackOk;
  419.  
  420.       ELSE (* Fehler aufgetreten *)
  421.  
  422.         IF  handlerOn  THEN
  423.           Stackhandler( procName, lastResult );
  424.         END;
  425.       END; (* IF done *)
  426.  
  427.     END; (* WITH stack^ *)
  428.  
  429.   END  Push;
  430.  
  431. (* ------------------------------------------------------------------------- *)
  432.  
  433. PROCEDURE  TopOfStack ((* EIN/ -- *) VAR stack : Stack;
  434.                        (* -- /AUS *) VAR wert  : ARRAY OF BYTE;
  435.                        (* -- /AUS *) VAR done  : BOOLEAN       );
  436. (*T*)
  437.   CONST  procName = 'TopOfStack';
  438.  
  439.   BEGIN
  440.     done       := FALSE;
  441.     lastResult := defErr;
  442.  
  443.     WITH  stack^  DO
  444.       IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  445.  
  446.          IF  elemSize # VAL( CARDINAL, HIGH( wert )) + 1   THEN
  447.            lastResult := sizeErr;
  448.  
  449.          ELSE (* Speicherplatz stimmt *)
  450.  
  451.            IF   Elemente = 0   THEN
  452.              lastResult := stackEmpty;  (* nix da *)
  453.  
  454.            ELSE  (* Stack nicht leer *)
  455.              done       := TRUE;
  456.              lastResult := stackOk;
  457.  
  458.              Copy( stackTop, ADR( wert ), elemSize );
  459.            END; (* IF Elemente *)
  460.          END; (* IF elemSize *)
  461.       END;(* IF stack # NIL ... *)
  462.     END; (* WITH stack^ *)
  463.  
  464.     IF  ~done  THEN
  465.       (* Zur Sicherheit den gelieferten
  466.        * ( nicht vorhandenen ) wert init.
  467.        *)
  468.       MEMORY.ClearMem( ADR( wert ), HIGH( wert ) + 1 );
  469.  
  470.       IF  handlerOn  THEN
  471.         Stackhandler( procName, lastResult );
  472.       END;
  473.     END; (* IF ~done *)
  474.  
  475.   END  TopOfStack;
  476.  
  477. (* ------------------------------------------------------------------------- *)
  478.  
  479. PROCEDURE  Drop ((* EIN/AUS *) VAR stack : Stack;
  480.                  (* -- /AUS *) VAR done  : BOOLEAN );
  481. (*T*)
  482.   CONST  procName = 'Drop';
  483.  
  484.   BEGIN
  485.     done       := FALSE;
  486.     lastResult := defErr;
  487.  
  488.     WITH  stack^  DO
  489.       IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  490.  
  491.         IF  Elemente > 0  THEN
  492.           done        := TRUE;
  493.           lastResult  := stackOk;
  494.  
  495.           DEC( Elemente );
  496.  
  497.           IF  ( Elemente > 0 ) & ( topElement > 0D )  THEN
  498.  
  499.             (* Wenn noch ein Element auf dem Stack ist, und das
  500.              * naechste Element noch innerhalb dieses Blocks ist,
  501.              * koennen Index und Adresse einfach verringert werden.
  502.              *)
  503.  
  504.             DEC( topElement );
  505.             DEC( stackTop, elemSize );
  506.  
  507.           ELSE (* <stack> leer oder lediglich oberster Block leer *)
  508.  
  509.             IF topBlock^ # NIL  THEN
  510.  
  511.               (* Wenn lediglich der oberste Block leer ist,
  512.                * aber nicht der Stack - d.h. es existieren noch
  513.                * weitere Bloecke -, den obersten Block entfernen.
  514.                * Der Zeiger aufs oberste Element muss aufs
  515.                * oberste Element des naechsten Blocks zeigen.
  516.                *)
  517.               ReleaseBlock ( stack );
  518.  
  519.               topElement := maxElement;
  520.               stackTop   :=   VAL( LONGINT, topBlock )
  521.                             + LONG( SIZE( block ))
  522.                             + maxElement * LONG( elemSize );
  523.  
  524.             ELSE (* der Stack ist leer *)
  525.  
  526.               topElement := -1;
  527.               stackTop   :=   VAL( ADDRESS, topBlock )
  528.                             - VAL( ADDRESS, elemSize )
  529.                             + LONG( SIZE( block ))
  530.  
  531.             END; (* IF topBlock^ *)
  532.           END; (* IF ( Elemente > 0 )... *)
  533.  
  534.         ELSE (* IF Elemente > 0 *)
  535.  
  536.           lastResult := stackEmpty
  537.         END; (* IF Elemente > 0 *)
  538.       END; (* IF stack # NIL *)
  539.     END; (* WITH stack^ *)
  540.  
  541.     IF  ~done & handlerOn  THEN
  542.       Stackhandler( procName, lastResult );
  543.     END;
  544.  
  545.   END  Drop;
  546.  
  547. (* ------------------------------------------------------------------------- *)
  548.  
  549. PROCEDURE  Pop ((* EIN/AUS *) VAR stack : Stack;
  550.                 (* -- /AUS *) VAR wert  : ARRAY OF BYTE;
  551.                 (* -- /AUS *) VAR done  : BOOLEAN       );
  552. (*T*)
  553.   CONST  procName = 'Pop';
  554.  
  555.   BEGIN
  556.     done       := FALSE;
  557.     lastResult := defErr;
  558.  
  559.     WITH  stack^  DO
  560.       IF  ( stack # NIL ) & ( stack^.stackAdr = ADR( stack ))  THEN
  561.  
  562.          IF  elemSize # VAL( CARDINAL, HIGH( wert )) + 1   THEN
  563.            lastResult := sizeErr;
  564.  
  565.          ELSE (* Speicherplatz stimmt *)
  566.  
  567.            IF   Elemente = 0   THEN
  568.              lastResult := stackEmpty;
  569.  
  570.            ELSE  (* Stack nicht leer *)
  571.              done       := TRUE;
  572.              lastResult := stackOk;
  573.  
  574.              Copy( stackTop, ADR( wert ), elemSize );
  575.  
  576.              DEC( Elemente );
  577.  
  578.              IF  ( Elemente > 0 ) & ( topElement > 0D )  THEN
  579.  
  580.                (* Wenn noch ein Element auf dem Stack ist, und das
  581.                 * naechste Element noch innerhalb dieses Blocks ist,
  582.                 * koennen Index und Adresse einfach verringert werden.
  583.                 *)
  584.  
  585.                DEC( topElement );
  586.                DEC( stackTop, elemSize );
  587.  
  588.              ELSE (* <stack> leer oder lediglich oberster Block leer *)
  589.  
  590.                IF topBlock^ # NIL  THEN
  591.  
  592.                  (* Wenn lediglich der oberste Block leer ist,
  593.                   * aber nicht der Stack - d.h. es existieren noch
  594.                   * weitere Bloecke -, den obersten Block entfernen.
  595.                   * Der Zeiger aufs oberste Element muss aufs
  596.                   * oberste Element des naechsten Blocks zeigen.
  597.                   *)
  598.                  ReleaseBlock ( stack );
  599.  
  600.                  topElement := maxElement;
  601.                  stackTop   :=   VAL( LONGINT, topBlock )
  602.                                + LONG( SIZE( block ))
  603.                                + maxElement * LONG( elemSize );
  604.  
  605.                ELSE (* der Stack ist leer *)
  606.  
  607.                  topElement := -1;
  608.                  stackTop   :=   VAL( ADDRESS, topBlock )
  609.                                - VAL( ADDRESS, elemSize )
  610.                                + LONG( SIZE( block ))
  611.  
  612.                END; (* IF topBlock^ *)
  613.              END; (* IF ( Elemente > 0 )... *)
  614.  
  615.            END; (* IF Elemente = 0 *)
  616.          END; (* IF elemSize *)
  617.       END; (* IF stack # NIL ... *)
  618.     END; (* WITH stack^ *)
  619.  
  620.     IF  ~done  THEN
  621.       MEMORY.ClearMem( ADR( wert ), HIGH( wert ) + 1 );
  622.  
  623.       IF  handlerOn  THEN
  624.         Stackhandler( procName, lastResult );
  625.       END;
  626.     END; (* IF ~done *)
  627.  
  628.   END  Pop;
  629.  
  630.  
  631. END  Stacks.
  632.  
  633.  
  634.  
  635.  
  636.